00100	COMMENT ⊗   VALID 00002 PAGES
00200	C REC  PAGE   DESCRIPTION
00300	C00001 00001
00400	C00002 00002	C  *****  NSCOL  JUL 14 74 -- FOR EXPORT -- WRITES ON MAGTAPE OR DSK.  
00500	C00009 ENDMK
00600	C⊗;
     

00200	C  ****** LOAD WITH CMUIO.REL  *********
00300	C   TO WRITE ON DSK: BIGBIT←1; OR RCDFLG←1;    TO WRITE ON TAPE: BIGBIT←-1;
00400	C  BIGBIT←>1; WRITES ON DSK, 4TH LETTER OF NAME IS SET BY NUMBER.
00500	C   IF RCDFLG IS NOT 0 OR 1, ONE LONG FILE IS WRITTEN. PLAY WITH 'PLAY'.
00600		SUBROUTINE SMPLS(LSBUF,ISBCNT,IBOTT,MAXAMP,BIGBIT,RCDFLG)
00700		COMMON JSB(10) /NM/INM(3),MQ(3)
00800	C***	COMMON /NICCOM/ NICNAM
00900	C*** TAKE OUT NICCOM IN MAIN PROG. AND HERE SOMETIME!
01000	CC***	DATA NICNAM /'MUSAA'/
01100		DIMENSION IBOTT(1)
01300		DATA INM(2)/' AMP='/
01400		IF(J)GO TO 6
01500	   	IEND=-1
01800		KR=-RCDFLG
02000		IMAX=50000
03300	1	INM(1)='MUSAA'+(KR-1)*2
03400	33	CALL PUTFIL(INM(1))
03500	34	J=-1
03800	666	IMAX=2050
05500	6	IF(MAXAMP.LT.IMAX)GO TO 44
05600	C  IABS(MAXAMP) WON'T WORK 1ST TIME AROUND!!!!!!!⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗⊗
05700	C   49999 IS MAXIMUM AMPL. POSSIBLE (ARBITRARY NUMBER.)
05800		CALL MESS(INM)
05900		CALL PNUM(MAXAMP)
06000		CALL PNUM(MAXAMP)
06100		RETURN
06200	44	CALL FASTOU(IBOTT(1),LSBUF)
06300	45	IF(ISBCNT.EQ.0)RETURN
06400		J=0
06600		CALL FINFIL
06900	2221	CALL MESS(INM)
07000		CALL PNUM(MAXAMP)
07200		END
07300	
07400	
07500	
07600		SUBROUTINE SEG(FUNC)
07700	C  TYPE AMPL, STEP# (UP TO STEP 512). SAME FORMAT AS GEN 1 IN MUSIC5.
07800		DIMENSION FUNC(512),A(4)
07900		COMMON K,STEP,AMP1,AMP2,DIF,IT,IS,ST,STPS,RK
08000		DATA (A(K),K=1,3)/'SEG ARRAY FULL/'/
08100	C   REMOVE ABOVE LATER******** MAYBE.
08200		AMP1=0
08300		ST=0
08400	1	CALL RDNUM(AMP2)
08500		CALL RDNUM(STEP)
08600		IF(STEP.GT.1.)GO TO 3
08700		AMP1=AMP2
08800		GO TO 1
08900	C  STEP=1 AND STEP=0 ARE CONSIDERED THE SAME.
09000	3	DIF=AMP2-AMP1
09100	5	IT=ST
09200		IS=STEP*5.120+.0001
09300		STEP=IS
09400	 	STPS=STEP-ST
09500		IS=STPS
09600		IF(IS+IT.GT.512)GO TO 6
09700		ST=STEP
09800		IF(ST.EQ.0)STEP=1.
09900		DO 2 K=1,IS
10000		RK=K
10100	2	FUNC(K+IT)=AMP1+DIF*RK/STPS
10200		AMP1=AMP2
10300	      	ST=STEP
10400		IF(STEP.LT.512)GO TO 1
10550	1102	CALL SEE(FUNC)
10560		CALL MESS(A)
10600		RETURN
10700	6	K=1
10800	C  NEXT TO READ IN FULL ARRAYS
10900	8	CALL RDNUM(RK)
11000	7	FUNC(K)=RK
11100		K=K+1
11200		IF(K.LE.512)GO TO 8
11300		GO TO 1102
11400		END
11500	
11600		SUBROUTINE SYNTH (FUNC)
11700	C    AFTER 'SYNTH(F1);'  TYPE 99= TO USE  H,A,P,K: OTHERWISE
11800	C    H,A ONLY.  TYPE 999 TO END. NORMALIZATION IS AUTOMATIC.
11900		DIMENSION FUNC(512),F(5)
12000		COMMON I,XX,X,H,K,CON,XK,FAC,AMP,Y
12100		DATA (F(I),I=1,4)/'SYNTH ARRAY FULL/'/
12200		DO 15 I=1,512
12300	15	FUNC(I)=0.0
12400	 	CALL RDNUM(XX)
12500		IF(XX.EQ.99)XX=-99
12600		FAC=360./512.
12700		H=XX
12800		IF(XX)CALL RDNUM(H)
12900	16	CALL RDNUM(AMP)
13000		IF(XX)GO TO 1016
13100		X=0
13200		CON=0
13300		GO TO 2016
13400	1016	CALL RDNUM(X)
13500		X=X*512./360.+1.0
13600		CALL RDNUM(CON)
13700	2016	DO 17 J=1,512
13800		XK=SIND(X*FAC)*AMP+CON
13900		IF(CON.LT.100.0)GO TO 1
14000		FUNC(J)=(XK-100.)*FUNC(J)
14100		GO TO 2
14200	1	FUNC(J)=FUNC(J)+XK
14300	2	X=X+H
14400		IF(X.LE.512.)GO TO 17
14500		X=X-512.
14600	17	CONTINUE
14700		CALL RDNUM(H)
14800		IF(H.NE.999.)GO TO 16
14900	2200	X=FUNC(1)
15000		DO 19 I=2,512
15100		H=ABS(FUNC(I))
15200	19	IF(X.LT.H)X=H
15300		DO 20 I=1,512
15400	20	FUNC(I)=FUNC(I)/X
15450		CALL SEE(FUNC)
15500		CALL MESS(F)
15700		END
16200	
16300		SUBROUTINE SEE(FUNC)
16400	
16500		DIMENSION FUNC(512),SU(150),C(3)
16600	 	DATA (C(I),I=1,2)/'0=CLEAR: '/
16700	CC	CALL DDCLR
16800	C  THIS VERSION MUST BE LOADED WITH %LTVRLIB (FOR 'DDCLR')
16900	CC	CALL TYPLOC(-300,-512)
17000		CALL DPYSET(2,SU,150)
17100	CC	CALL DPYBRT(6)
17200		CALL ALINE(-264,0,256,0)
17300		CALL ALINE(-256,-256,-256,256)
17400		CALL AIVECT(0,0)
17500	1	IY=FUNC(1)*256.0
17600		CALL AIVECT(-256,IY)
17700		DO 14 I=2,512,3
17800		IY2=FUNC(I)*256.0
17900		CALL RVECT(3,IY2-IY)
18000	14	IY=IY2
18100		CALL DPYOUT(2)
18200	CS100	CALL MESS(C)
18300	CS1100   	CALL RDNUM(X)
18400	CS	CALL DPYCLR
18500		END